#!/usr/bin/perl -wc

# A collection of DNS resource records (object model)

package RFCMail::DNS::Snapshot;

use strict;
use warnings;


sub new {
    my ($class) = @_;
    return (bless {}, $class);
}


sub summary {
    my $self = shift;
    my @result = map {
	if ($self->has_node($_)) {
	    my $node = $self->node($_);
	    my $status = join(", ", $node->query->summary);
	    my $title = "$_." . ($status ? " ($status)" : "") . "\n";
	    my $rrs = join("", map("\t$_\n", $node->rrset->summary));
	    "$title$rrs";
	}
	else {
	    "$_ is not a known node\n";
	}
    } @_ ? @_ : (sort keys %$self);
    return (@result);
}


sub have_answer {
    my ($self, $name, $type) = @_;
    my $node = $self->node($name);
    if ($type) {
	my $status = $node->query->get($type);
	return ($status)
	    if $status;
    }
    return ($node->rrset->get($type));
}


sub add_response {
    my ($self, $response) = @_;
    for ($response->question) {
	$self->make_node($_->qname)->make_query->set($_->qtype, $response->header->rcode);
    }
    for ($response->answer, $response->authority, $response->additional) {
	$self->make_node($_->name)->make_rrset->add($_);
    }
    return ($self);
}


sub rrs {
    my ($self, $name, $type) = @_;
    return ($self->node($name)->rrset->get($type));
}


sub rcode {
    my ($self, $name, $qtype) = @_;
    return ($self->node($name)->query->get($qtype))
	if $name;
    return (grep($self->{$_}->query->get, keys %$self));
}


sub errors {
    my ($self, $name, $qtype) = @_;
    return ($self->node($name)->query->errors->get($qtype))
	if $name;
    return (grep($self->{$_}->query->errors->get, keys %$self));
}


# Everything below this point is considered internal/private


sub has_node { op_node(@_, 0) } # returns boolean

sub node { op_node(@_, 1) } # returns existing or empty fake

sub make_node { op_node(@_, 2) } # returns node (creating if necessary)

sub op_node {
    my ($self, $name, $op) = @_;
    # ops : 0 => exists, 1 => get, 2 => make
    $name = lc($name);
    my $node = $self->{$name};
    return ($op ? $node : 1)
	if $node;
    return ("")
	if not $op;
    $node = RFCMail::DNS::Snapshot::Node->new;
    $self->{$name} = $node
	if $op == 2;
    return ($node);
}



package RFCMail::DNS::Snapshot::Node;

use strict;
use warnings;


sub new {
    my ($class) = @_;
    return (bless [undef, undef], $class);
}


sub has_rrset { op_node(@_, 0, 0) }

sub rrset { op_node(@_, 0, 1) }

sub make_rrset { op_node(@_, 0, 2) }

sub has_query { op_node(@_, 1, 0) }

sub query { op_node(@_, 1, 1) }

sub make_query { op_node(@_, 1, 2) }

sub op_node {
    my ($self, $type, $op) = @_;
    # types: 0 => rrset, 1 => queries
    # ops: 0 => exists, 1 => get, 2 => make
    my $node = $self->[$type];
    return ($op ? $node : 1)
	if $node;
    return ("")
	if not $op;
    $node = $type ? RFCMail::DNS::Snapshot::Query->new : RFCMail::DNS::Snapshot::RRSet->new;
    $self->[$type] = $node
	if $op == 2;
    return ($node);
}



package RFCMail::DNS::Snapshot::RRSet;

use strict;
use warnings;


sub new {
    my ($class) = @_;
    return (bless {}, $class);
}


sub summary {
    my $self = shift;
    return (sort keys %{$self});
}


sub get {
    my ($self, $type) = @_;
    $type = uc($type)
	if defined($type);
    undef($type)
	if $type eq 'ANY';
    my @rrs = values(%{$self});
    return (@rrs)
	if not defined($type);
    return (grep($_->type eq $type, @rrs));
}


sub add {
    my $self = shift;
    for (@_) {
	my $key = $_->type . " " . $_->rdatastr;
	$self->{$key} = $_;
    }
}



package RFCMail::DNS::Snapshot::Query;

use strict;
use warnings;


sub new {
    my ($class) = @_;
    return (bless {}, $class);
}


sub summary {
    my ($self) = @_;
    return (map("$_: ".$self->{$_}, sort keys %$self));
}


sub errors {
    my ($self) = @_;
    my $result = RFCMail::DNS::Snapshot::Query->new;
    for (keys %$self) {
	$result->set($_, $self->{$_})
	    if $self->{$_} ne 'NOERROR';
    }
    return ($result);
}


sub get {
    my ($self, $qtype) = @_;
    return (%$self)
	if not defined($qtype);
    return ($self->{uc($qtype)});
}


sub set {
    my ($self, $qtype, $status) = @_;
    $qtype = uc($qtype);
    $self->{$qtype} = $status;
    return ($self);
}


1;
